home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / 2.01 sources / Library-2.01 / scroll-bar-dialog-items.Lisp < prev   
Encoding:
Text File  |  1993-09-16  |  41.1 KB  |  1,035 lines  |  [TEXT/CCL2]
  1. ;;-*- Mode: Lisp; Package: CCL -*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;  scroll-bar-dialog-items.lisp
  4. ;;
  5. ;;
  6. ;;  ©1989, Apple Computer, Inc
  7. ;;
  8. ;;  the code in this file implements a scroll-bar class of dialog-items
  9. ;;
  10.  
  11.  
  12. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13. ;;
  14. ;; Change history
  15. ;;
  16. ;; 04/28/93 mwp Release
  17. ;; 07/17/92 bill Do the right thing for :view-size initarg and
  18. ;;               no :length or :width initarg.
  19. ;; 06/04/92 bill Do not ignore the :setting initarg
  20. ;; ------------
  21. ;; 03/20/92 bill fix completely bogus conversions in mac-scroll-bar-setting
  22. ;;               and outside-scroll-bar-setting.
  23. ;; ------------- 2.0f3
  24. ;; 01/06/92 bill Fix a bug in the ROM that enables a scroll bar on exiting
  25. ;;               #_TrackControl. This allows user dialog-item-action functions
  26. ;;               to disable the scroll bar while it is being tracked.
  27. ;;               Adjust initial mouse position for scroll-position in
  28. ;;               track-scroll-bar-thumb.
  29. ;;               install-view-in-window disables the scroll bar if appropriate.
  30. ;;               New mapping of user-visible min & max to what the ROM sees so
  31. ;;               that the scroll bar will be disabled when max=min.
  32. ;; 12/30/91 bill :pane-splitter should be :left or :right for a
  33. ;;               horizontal scroll bar (vice :top or :bottom)
  34. ;;               set-scroll-bar-width works correctly for inactive scroll bars.
  35. ;;               inactive scroll bars get drawn after set-view-container.
  36. ;;               :srcxor -> :patxor
  37. ;;               Window.updateRgn -> WindowRecord.updateRgn
  38. ;;               Remove %pane-splitter-outline-position.
  39. ;;               Thanx to STEVE.M
  40. ;; ------------- 2.0b4
  41. ;; 11/12/91 bill (from dds)
  42. ;;               :control.vis -> :controlRecord.ContrlVis
  43. ;;               :control.owner -> :controlRecord.ContrlOwner
  44. ;; 10/17/91 bill Use #_TrackControl vice track-scroll-bar-thumb if
  45. ;;               not doing real time scrolling.  Disable periodic tasks
  46. ;;               that draw during real time scrolling.
  47. ;; 10/15/91 bill #_ShowControl & #_HideControl add to the invalid region.
  48. ;;               Add a #_ValidRect in view-(de)activate-event-handler
  49. ;; -------------- 2.0b3
  50. ;; 08/26/91 bill no more (require 'traps)
  51. ;; 08/25/91 gb   use new trap syntax.
  52. ;; 08/08/91 bill set-view-container now handles the view-deactivate-event-handler
  53. ;;               that was in install-view-in-window here.
  54. ;; 07/18/91 bill Prevent divide by zero in mac-scroll-bar-setting
  55. ;; 04/16/91 bill pane-splitter-outline-position
  56. ;; 03/22/91 bill make scroll bars & pane-splitters disappear when the 
  57. ;;               window is not active.
  58. ;; 03/11/91 bill WRS's pane-splitter-corners fix.
  59. ;; 03/04/91 bill increase setting range to beyond [-32768 32767]
  60. ;; 02/22/91 bill make the scroll bar initially invisible so
  61. ;;               we don't need to focus-view in install-view-in-window.
  62. ;;--------------- 2.0b1
  63. ;; 01/28/91 bill event.where -> eventRecord.where
  64. ;;
  65.  
  66. (in-package :ccl)
  67.  
  68. (eval-when (:compile-toplevel :load-toplevel :execute)
  69.   (export '(scroll-bar-dialog-item scroll-bar-setting
  70.             scroll-bar-min scroll-bar-max scroll-bar-length scroll-bar-width
  71.             scroll-bar-page-size  scroll-bar-scroll-size scroll-bar-scrollee
  72.             set-scroll-bar-setting set-scroll-bar-min set-scroll-bar-max
  73.             set-scroll-bar-length set-scroll-bar-width set-scroll-bar-scrollee
  74.             scroll-bar-changed track-scroll-bar
  75.         scroll-bar-track-thumb-p set-scroll-bar-track-thumb-p
  76.             pane-splitter split-pane pane-splitter-corners
  77.             pane-splitter-position set-pane-splitter-position
  78.             draw-pane-splitter-outline pane-splitter-outline-position
  79.             view-scroll-bars)
  80.           :ccl))
  81.  
  82.  
  83. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  84. ;; a few things that need to be around at compile time, but not run time
  85. ;;
  86. (eval-when (:compile-toplevel :execute)
  87.  
  88.   ;some constants for tracking the clicks in the scroll-bar
  89.   (defconstant $InUpButton 20)
  90.   (defconstant $InDownButton 21)
  91.   (defconstant $InPageUp 22)
  92.   (defconstant $InPageDown 23)
  93.   (defconstant $InThumb 129))
  94.  
  95. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  96. ;;scroll-bar-dialog-item
  97. ;;
  98.  
  99. (defclass scroll-bar-dialog-item (control-dialog-item)
  100.   ((procid :allocation :class :initform #$scrollBarProc)
  101.    (direction :initarg :direction :reader scroll-bar-direction)  
  102.    (min :initarg :min :reader scroll-bar-min)
  103.    (max :initarg :max :reader scroll-bar-max)
  104.    (setting :initarg :setting :reader scroll-bar-setting)
  105.    (track-thumb-p :initarg :track-thumb-p :initform nil
  106.                   :accessor scroll-bar-track-thumb-p)
  107.    (page-size :initarg :page-size :initform 5 :accessor scroll-bar-page-size)
  108.    (scroll-size :initarg :scroll-size :initform 1 :accessor scroll-bar-scroll-size)
  109.    (scrollee :initarg :scrollee :initform nil :reader scroll-bar-scrollee)
  110.    (pane-splitter :initform nil :accessor pane-splitter)
  111.    (pane-splitter-position :initform nil :initarg :pane-splitter 
  112.                            :reader pane-splitter-position)))
  113.  
  114. (defclass pane-splitter (simple-view)
  115.   ((scrollee :initarg :scrollee 
  116.              :reader scroll-bar-scrollee)
  117.    (direction :initarg :direction :reader scroll-bar-direction)
  118.    (scroll-bar :initarg :scroll-bar :initform nil :reader scroll-bar)))
  119.  
  120. ; Args would be in wrong order if these were defined as :writer's
  121. (defmethod set-scroll-bar-track-thumb-p ((item scroll-bar-dialog-item) value)
  122.   (setf (scroll-bar-track-thumb-p item) value))
  123.  
  124. (defmethod set-scroll-bar-scrollee ((view pane-splitter) value)
  125.   (setf (slot-value view 'scrollee) value))
  126.  
  127.  
  128. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  129. ;;initialize-instance
  130. ;;
  131. ;;initargs:
  132. ;;   length
  133. ;;   width
  134. ;;   direction
  135. ;;   setting
  136. ;;   min
  137. ;;   max
  138. ;;   page-size
  139. ;;   track-thumb-p
  140. ;;
  141. ;;in addition, the standard dialog-item initargs can be used
  142. ;;Size can be specified by either the view-size initarg or
  143. ;;the length & width initargs, but not both.
  144. ;;
  145.  
  146. (defmethod initialize-instance ((item scroll-bar-dialog-item) &rest initargs
  147.                                 &key (min 0) (max 100) (setting 0) width
  148.                                 (direction :vertical) length scrollee
  149.                                 pane-splitter (pane-splitter-length 7) view-size
  150.                                 view-position view-container)
  151.   (declare (dynamic-extent initargs))
  152.   (setq max (max min max)
  153.         setting (min (max setting min) max))
  154.   (if (and view-size (or length width))
  155.     (error "Both ~s and ~s were specified."
  156.            ':view-size (if length :length :width)))
  157.   (unless length
  158.     (setq length
  159.           (if view-size
  160.             (ecase direction
  161.               (:vertical (point-v view-size))
  162.               (:horizontal (point-h view-size)))
  163.             100)))
  164.   (unless width
  165.     (setq width
  166.           (if view-size
  167.             (ecase direction
  168.               (:vertical (point-h view-size))
  169.               (:horizontal (point-v view-size)))
  170.             16)))
  171.   (when pane-splitter
  172.     (let* ((splitter (make-instance 'pane-splitter 
  173.                                     :direction direction
  174.                                     :width width
  175.                                     :length pane-splitter-length
  176.                                     :scroll-bar item
  177.                                     :scrollee scrollee))
  178.            (size (view-size splitter))
  179.            (h (point-h size))
  180.            (v (point-v size)))
  181.       (setf (pane-splitter item) splitter)
  182.       (if (eq direction :vertical)
  183.         (progn
  184.           (decf length v)
  185.           (when view-position
  186.             (let ((p-h (point-h view-position))
  187.                   (p-v (point-v view-position)))
  188.               (if (eq pane-splitter :top)
  189.                 (progn
  190.                   (set-view-position splitter view-position)
  191.                   (setq view-position (make-point p-h (+ p-v v))))
  192.                 (progn
  193.                   (set-view-position splitter p-h (+ p-v length)))))))
  194.         (progn
  195.           (decf length h)
  196.           (when view-position
  197.             (let ((p-h (point-h view-position))
  198.                   (p-v (point-v view-position)))
  199.               (if (eq pane-splitter :left)
  200.                 (progn
  201.                   (set-view-position splitter view-position)
  202.                   (setq view-position (make-point (+ p-h h) p-v)))
  203.                 (progn
  204.                   (set-view-position splitter (+ p-h length) p-v)))))))))
  205.   (apply #'call-next-method
  206.          item
  207.          :min min
  208.          :max max
  209.          :setting setting
  210.          :direction direction
  211.          :length length
  212.          :view-container nil
  213.          :view-position view-position
  214.          :view-size
  215.          (case direction
  216.            (:vertical (make-point width length))
  217.            (:horizontal (make-point length width))
  218.            (t (error "illegal :direction ~a (must be :vertical or :horizontal)."
  219.                      direction)))
  220.          initargs)
  221.   (when (and pane-splitter view-container (not view-position))
  222.     (set-default-size-and-position item view-container)
  223.     (set-view-position item (view-position item)))
  224.   (when view-container
  225.     (set-view-container item view-container))
  226.   (when scrollee
  227.     (add-view-scroll-bar scrollee item)))
  228.  
  229. (defun view-scroll-bars (view)
  230.   (view-get view 'scroll-bars))
  231.  
  232. (defun add-view-scroll-bar (view scroll-bar)
  233.   (pushnew scroll-bar (view-get view 'scroll-bars)))
  234.  
  235. (defun delete-view-scroll-bar (view scroll-bar)
  236.   (setf (view-get view 'scroll-bars)
  237.         (delete scroll-bar (view-get view 'scroll-bars))))
  238.  
  239. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  240. ;;install-view-in-window
  241. ;;
  242. ;;  this is when we actually create the control (when the item
  243. ;;  is added to a window)
  244.  
  245. (defconstant $scroll-bar-max 16384)
  246.  
  247. (defun mac-scroll-bar-min-max (min max &aux dif)
  248.   (unless (>= max min) (setq max min))
  249.   (cond ((and (>= min (- $scroll-bar-max)) (<= max $scroll-bar-max))
  250.          (values min max))
  251.         ((< (setq dif (- max min)) (+ $scroll-bar-max $scroll-bar-max))
  252.          (let ((min-return
  253.                 (max (- $scroll-bar-max)
  254.                      (min min (- $scroll-bar-max dif)))))
  255.            (values min-return (+ min-return dif))))
  256.         (t (values (- $scroll-bar-max) $scroll-bar-max))))
  257.  
  258. (defun mac-scroll-bar-setting (setting min max &optional mac-min mac-max)
  259.   (if (<= max min)
  260.     min
  261.     (progn
  262.       (unless (and mac-min mac-max)
  263.         (multiple-value-setq (mac-min mac-max) (mac-scroll-bar-min-max min max)))
  264.       (min mac-max
  265.            (+ mac-min
  266.               (round (* (- setting min) (- mac-max mac-min)) (- max min)))))))
  267.  
  268. (defun outside-scroll-bar-setting (scroll-bar handle)
  269.   (let ((mac-setting (#_GetCtlValue handle))
  270.         (mac-min (#_GetCtlMin handle))
  271.         (mac-max (#_GetCtlMax handle))
  272.         (min (scroll-bar-min scroll-bar))
  273.         (max (scroll-bar-max scroll-bar)))
  274.     (declare (fixnum mac-min mac-max))
  275.     (if (eql mac-min mac-max)
  276.       mac-min
  277.       (+ min (round (* (- mac-setting mac-min) (- max min)) (- mac-max mac-min))))))
  278.  
  279. (defmethod install-view-in-window :after ((item scroll-bar-dialog-item) view)
  280.   (declare (ignore view))
  281.   (let* ((window (view-window item))
  282.          (my-size (view-size item))
  283.          (my-position (view-position item))
  284.          (setting (scroll-bar-setting item))
  285.          (min (scroll-bar-min item))
  286.          (max (scroll-bar-max item))
  287.          (mac-setting (mac-scroll-bar-setting setting min max)))
  288.     (multiple-value-bind (mac-min mac-max) (mac-scroll-bar-min-max min max)
  289.       (when window
  290.         (rlet ((scroll-rect :rect))
  291.           (rset scroll-rect rect.topleft my-position)
  292.           (rset scroll-rect rect.bottomright (add-points my-position my-size))
  293.           (let ((handle (dialog-item-handle item)))
  294.             (setf (dialog-item-handle item) nil)          ; I'm paranoid
  295.             (when handle
  296.               (#_DisposeControl handle)))
  297.           (setf (dialog-item-handle item)
  298.                 (#_NewControl 
  299.                  (wptr item)            ;window
  300.                  scroll-rect            ;item rectangle
  301.                  (%null-ptr)            ;title
  302.                  nil                    ;visible-p: invisible initially.
  303.                  mac-setting            ;initial value
  304.                  mac-min                ;min value
  305.                  mac-max                ;max value
  306.                  16                     ;type of control
  307.                  0)))                   ;refcon
  308.         (unless (dialog-item-enabled-p item)
  309.           (#_HiliteControl (dialog-item-handle item) 255))
  310.         ; Make sure the pane splitter is in the right place
  311.         (when (pane-splitter item)
  312.           (set-view-position item (view-position item)))))))
  313.  
  314. ; This ensures that the scroll bar gets drawn right
  315. ; after it is installed.
  316. (defmethod set-view-container :after ((item scroll-bar-dialog-item) container)
  317.   (when container
  318.     (multiple-value-bind (tl br) (scroll-bar-and-splitter-corners item)
  319.       (invalidate-corners container tl br))))
  320.     
  321. (defmethod remove-view-from-window :before ((item scroll-bar-dialog-item))
  322.   (let ((handle (dialog-item-handle item)))
  323.     (when handle
  324.       (setf (dialog-item-handle item) nil)
  325.       (#_DisposeControl handle))))
  326.  
  327.  
  328. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  329. ;;view-draw-contents
  330. ;;
  331. ;;this function is called whenever the item needs to be drawn
  332. ;;
  333. ;;to draw the dialog-item, we just call _Draw1Control
  334. ;;unless we just created it and it's still invisible.
  335. ;;
  336.  
  337. (defmethod view-draw-contents ((item scroll-bar-dialog-item))
  338.   (let ((handle (dialog-item-handle item)))
  339.     (when handle
  340.       (if (window-active-p (view-window item))
  341.         (if (neq 0 (href handle controlRecord.contrlvis))
  342.           (#_Draw1Control handle)
  343.           (#_ShowControl handle))
  344.         (multiple-value-bind (tl br) (scroll-bar-and-splitter-corners item)
  345.           (rlet ((rect :rect :topLeft tl :botRight br))
  346.             (#_FrameRect rect)))))))
  347.  
  348. (defun scroll-bar-and-splitter-corners (scroll-bar)
  349.   (multiple-value-bind (tl br) (view-corners scroll-bar)
  350.     (let ((splitter (pane-splitter scroll-bar)))
  351.       (if splitter
  352.         (multiple-value-bind (stl sbr) (view-corners splitter)
  353.           (values (make-point (min (point-h tl) (point-h stl))
  354.                               (min (point-v tl) (point-v stl)))
  355.                   (make-point (max (point-h br) (point-h sbr))
  356.                               (max (point-v br) (point-v sbr)))))
  357.         (values tl br)))))
  358.  
  359. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  360. ;;view-deactivate-event-handler
  361. ;;
  362. ;;this function is called whenever the scrollbar needs to be deactivated
  363. ;;
  364.  
  365. (defmethod view-deactivate-event-handler ((item scroll-bar-dialog-item))
  366.   (let ((handle (dialog-item-handle item))
  367.         (container (view-container item)))
  368.     (when handle
  369.       (with-focused-view container
  370.         (unless (window-active-p (view-window item))
  371.           (multiple-value-bind (tl br) (scroll-bar-and-splitter-corners item)
  372.             (rlet ((rect :rect
  373.                          :topLeft (add-points tl #@(1 1))
  374.                          :botRight (subtract-points br #@(1 1))))
  375.               (with-clip-rect rect
  376.                 ; #_HideControl invals outside of the clip rect.  Naughty, naughty.
  377.                 (let* ((wptr (href handle :controlRecord.ContrlOwner))
  378.                        (update-rgn (pref wptr :windowRecord.updateRgn))
  379.                        (temp-rgn *temp-rgn*))
  380.                   (declare (dynamic-extent wptr update-rgn)
  381.                            (type macptr wptr update-rgn))
  382.                   (#_CopyRgn update-rgn temp-rgn)
  383.                   (#_HideControl handle)
  384.                   (#_CopyRgn temp-rgn update-rgn))
  385.                 (#_EraseRect rect)
  386.                 (validate-corners container tl br))))))
  387.       (#_hilitecontrol handle 255))))
  388.  
  389. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  390. ;;view-activate-event-handler
  391. ;;
  392. ;;this function is called whenever the scrollbar needs to be activated
  393. ;;
  394.  
  395. (defmethod view-activate-event-handler ((item scroll-bar-dialog-item))
  396.   (when (let ((w (view-window item)))
  397.           (and w (window-active-p w)))
  398.     (let ((handle (dialog-item-handle item))
  399.           (container (view-container item)))
  400.       (with-focused-view container
  401.         (when (dialog-item-enabled-p item)
  402.           (#_hilitecontrol handle 0))
  403.         (unless (neq 0 (rref handle :controlRecord.ContrlVis))
  404.           ; #_ShowControl is similarly naughty
  405.           (let* ((wptr (href handle :controlRecord.ContrlOwner))
  406.                  (update-rgn (pref wptr :windowRecord.updateRgn))
  407.                  (temp-rgn *temp-rgn*))
  408.             (declare (dynamic-extent wptr update-rgn)
  409.                      (type macptr wptr update-rgn))
  410.             (#_CopyRgn update-rgn temp-rgn)
  411.             (#_ShowControl handle)
  412.             (#_CopyRgn temp-rgn update-rgn))
  413.           (let ((splitter (pane-splitter item)))
  414.             (when splitter (view-draw-contents splitter)))
  415.           (multiple-value-bind (tl br) (scroll-bar-and-splitter-corners item)
  416.             (validate-corners container tl br)))))))
  417.  
  418.  
  419. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  420. ;;dialog-item-enable
  421. ;;
  422. ;; Need to patch the system-supplied method for control-dialog-item
  423. ;; scroll bars are not visibly enabled unless the window they're on
  424. ;; is the top window.
  425.  
  426. (defmethod dialog-item-enable ((item scroll-bar-dialog-item))
  427.   (unless (dialog-item-enabled-p item)
  428.     (setf (dialog-item-enabled-p item) t)
  429.     (view-activate-event-handler item)))
  430.  
  431.  
  432. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  433. ;;dialog-item-disable
  434. ;;
  435. ;; Patch the control-dialog-item method to delay
  436. ;; the actual disable during scrolling.
  437. ;; This gets around a bug in the Mac ROM where the scroll
  438. ;; a control is enabled just before #_TrackControl returns.
  439.  
  440. ; This is bound to the scroll bar that is currently being tracked.
  441. (defvar *scroll-bar-item* nil)
  442.  
  443. (defmethod dialog-item-disable ((item scroll-bar-dialog-item))
  444.   (if (eq item *scroll-bar-item*)
  445.     (setf (dialog-item-enabled-p item) nil)
  446.     (call-next-method)))
  447.  
  448. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  449. ;;scroll-bar-proc
  450. ;;
  451. ;;this is the hook function which is passed to _TrackControl.  The toolbox
  452. ;;  will call this function periodically as the control is clicked.
  453. ;;
  454. ;; It calls track-scroll-bar every time the ROM calls it.
  455. ;; The default version of track-scroll-bat updates the
  456. ;; scroll bar position according to the scroll-bar-scroll-size or
  457. ;; scroll-bar-page-size and calls dialog-item-action.
  458. ;; User's may shadow the default method if they need custom behavior.
  459.  
  460. (defpascal scroll-bar-proc (:ptr sb-handle :word part)
  461.   "This procedure adjusts the control value, and calls dialog-item-action."
  462.   (let ((item *scroll-bar-item*))
  463.     (track-scroll-bar
  464.      item
  465.      (if (eq part #.$InThumb)
  466.        (outside-scroll-bar-setting item sb-handle)
  467.        (scroll-bar-setting item))
  468.      (case part
  469.        (#.$InUpButton :in-up-button)
  470.        (#.$InDownButton :in-down-button)
  471.        (#.$InPageUp :in-page-up)
  472.        (#.$InPageDown :in-page-down)
  473.        (#.$InThumb :in-thumb)
  474.        (t nil)))))
  475.  
  476. (eval-when (:compile-toplevel :execute)
  477.   (require "LISPEQU"))                  ; for $ptask_draw-flag
  478.  
  479. ;; Unfortunately, the ROM is brain-damaged, so we have to do this ourselves.
  480. (defun track-scroll-bar-thumb (item)
  481.   (let* ((old-setting (scroll-bar-setting item))
  482.          (min (scroll-bar-min item))
  483.          (max (scroll-bar-max item))
  484.          (horizontal? (eq (scroll-bar-direction item) :horizontal))
  485.          (position (view-position item))
  486.          (last-mouse (rref *current-event* :eventRecord.where))
  487.          (size (view-size item))
  488.          (real-time-tracking (scroll-bar-track-thumb-p item))
  489.          ; disable periodic tasks that draw
  490.          (*periodic-task-mask* (logior (the fixnum *periodic-task-mask*)
  491.                                        $ptask_draw-flag))
  492.          width length old-mouse left right mouse setting)
  493.     (setq last-mouse
  494.           ; global-to-local
  495.           (add-points (view-origin item)
  496.                       (subtract-points last-mouse (view-position (view-window item)))))
  497.     (if horizontal?
  498.       (setq width (point-v size)
  499.             length (- (point-h size) width width width)
  500.             left (+ (round (* width 3) 2) (point-h position))
  501.             old-mouse (point-h last-mouse))
  502.       (setq width (point-h size)
  503.             length (- (point-v size) width width width)
  504.             left (+ (round (* width 3) 2) (point-v position))
  505.             old-mouse (point-v last-mouse)))
  506.     (setq right (+ left length))
  507.     (loop
  508.       (unless (mouse-down-p)
  509.         (unless (or real-time-tracking (not setting))
  510.           (track-scroll-bar item setting :in-thumb))
  511.         (return))
  512.       (setq mouse (view-mouse-position item))
  513.       (unless (eql mouse last-mouse)
  514.         (setq last-mouse mouse)
  515.         (setq mouse (if horizontal? (point-h mouse) (point-v mouse)))
  516.         (setq setting (min max
  517.                            (max min
  518.                                 (+ old-setting
  519.                                    (round (* (- mouse old-mouse) (- max min))
  520.                                           (- right left))))))
  521.         (if real-time-tracking
  522.           (track-scroll-bar item setting :in-thumb)
  523.           (set-scroll-bar-setting item setting))))))
  524.  
  525. ; Returns the new value for the scroll bar
  526. (defmethod track-scroll-bar ((item scroll-bar-dialog-item) value part)
  527.   (set-scroll-bar-setting 
  528.    item
  529.    (case part
  530.      (:in-up-button (- value (scroll-bar-scroll-size item)))
  531.      (:in-down-button (+ value (scroll-bar-scroll-size item)))
  532.      (:in-page-up (- value (scroll-bar-page-size item)))
  533.      (:in-page-down (+ value (scroll-bar-page-size item)))
  534.      (t value)))
  535.   (dialog-item-action item))
  536.  
  537.  
  538. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  539. ;;view-click-event-handler
  540. ;;
  541. ;;this is the function which is called when the user clicks in the scroll-bar
  542. ;;
  543. ;;It checks the scroll-bar part, and calls _TrackControl
  544. ;;  If appropriate, it passes a hook function to _TrackControl
  545. ;;
  546. ;;During tracking, dialog-item-action is repeatedly called.
  547. ;;
  548.  
  549. (defmethod view-click-event-handler ((item scroll-bar-dialog-item) where)
  550.   (let* ((sb-handle (dialog-item-handle item))
  551.          (part (#_TestControl sb-handle where)))
  552.     (cond ((eq part #.$InThumb)
  553.            (if (scroll-bar-track-thumb-p item)
  554.              (track-scroll-bar-thumb item)
  555.              (progn
  556.                (let ((*scroll-bar-item* item))
  557.                  (#_TrackControl sb-handle where (%null-ptr)))
  558.                (track-scroll-bar
  559.                 item (outside-scroll-bar-setting item sb-handle) :in-thumb))))
  560.           ((memq part '(#.$InUpButton #.$InDownButton
  561.                         #.$InPageUp #.$InPageDown))
  562.            (let ((was-enabled (dialog-item-enabled-p item)))
  563.              (let ((*scroll-bar-item* item))
  564.                (#_TrackControl sb-handle where scroll-bar-proc))
  565.              ; The ROM enables on its way out
  566.              (when (and was-enabled (not (dialog-item-enabled-p item)))
  567.                (#_HiliteControl sb-handle 255)))))))
  568.  
  569.  
  570.  
  571. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  572. ;;dialog-item-action
  573. ;;
  574. ;;The default dialog-item-action for a scroll bar calls
  575. ;;scroll-bar-changed on the scrollee
  576. ;;
  577. (defmethod dialog-item-action ((item scroll-bar-dialog-item))
  578.   (let ((f (dialog-item-action-function item)))
  579.     (if f
  580.       (funcall f item)
  581.       (let ((scrollee (scroll-bar-scrollee item)))
  582.         (when scrollee
  583.           (scroll-bar-changed scrollee item))))))
  584.  
  585. (defmethod scroll-bar-changed (view scroll-bar)
  586.   (declare (ignore view scroll-bar)))
  587.  
  588. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  589. ;;(setf scroll-bar-setting)
  590. ;;
  591. ;;a nice safe Lisp-level function for changing the value of the scroll-bar
  592. ;;The accessor is defined by the DEFCLASS
  593. ;;
  594.  
  595. (defmethod (setf scroll-bar-setting) (new-value (item scroll-bar-dialog-item))
  596.   (set-scroll-bar-setting item new-value))
  597.  
  598. (defmethod set-scroll-bar-setting ((item scroll-bar-dialog-item) new-value)
  599.   (setq new-value (require-type new-value 'fixnum))
  600.   (%set-scroll-bar-setting item new-value t))
  601.  
  602. (defun %set-scroll-bar-setting (item new-value only-if-new-value)
  603.   (setq new-value (max (scroll-bar-min item) (min (scroll-bar-max item) new-value)))
  604.   (unless (and only-if-new-value (eql new-value (scroll-bar-setting item)))
  605.     (let ((handle (dialog-item-handle item)))
  606.       (when handle
  607.         (with-focused-view (view-container item)
  608.           (#_SetCtlValue 
  609.            handle 
  610.            (mac-scroll-bar-setting 
  611.             new-value 
  612.             (scroll-bar-min item) 
  613.             (scroll-bar-max item))))))
  614.     (setf (slot-value item 'setting) new-value))
  615.   new-value)
  616.  
  617. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  618. ;;scroll-bar-min is a :reader for the class
  619. ;;here's the setter
  620. ;;
  621. (defmethod (setf scroll-bar-min) (new-value (item scroll-bar-dialog-item))
  622.   (set-scroll-bar-min item new-value))
  623.  
  624. (defmethod set-scroll-bar-min ((item scroll-bar-dialog-item) new-value)
  625.   (setq new-value (require-type new-value 'fixnum))
  626.   (unless (eql new-value (scroll-bar-min item))
  627.     (setf (slot-value item 'min) new-value)
  628.     (update-scroll-bar-max-min-setting item))
  629.   new-value)
  630.  
  631.  
  632. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  633. ;;scroll-bar-max is a :reader for the class
  634. ;;here's the setter
  635. ;;
  636. (defmethod (setf scroll-bar-max) (new-value (item scroll-bar-dialog-item))
  637.   (set-scroll-bar-max item new-value))
  638.  
  639. (defmethod set-scroll-bar-max ((item scroll-bar-dialog-item) new-value)
  640.   (setq new-value (require-type new-value 'fixnum))
  641.   (unless (eql new-value (scroll-bar-max item))
  642.     (setf (slot-value item 'max) new-value)
  643.     (update-scroll-bar-max-min-setting item))
  644.   new-value)
  645.  
  646. (defun update-scroll-bar-max-min-setting (item)
  647.   (let ((handle (dialog-item-handle item)))
  648.     (when handle
  649.       (with-focused-view (view-container item)
  650.         (let ((max (scroll-bar-max item))
  651.               (min (scroll-bar-min item))
  652.               (setting (scroll-bar-setting item)))
  653.           (multiple-value-bind (mac-min mac-max) (mac-scroll-bar-min-max min max)
  654.             (let ((mac-setting (mac-scroll-bar-setting setting min max mac-min mac-max)))
  655.               (cond ((not (eql mac-min (href handle :controlrecord.contrlmin)))
  656.                      (setf (href handle :controlrecord.contrlmax) mac-max
  657.                            (href handle :controlrecord.contrlvalue) mac-setting)
  658.                      (#_SetCtlMin handle mac-min))
  659.                     ((not (eql mac-max (href handle :controlrecord.contrlmax)))
  660.                      (setf (href handle :controlrecord.contrlmin) mac-min
  661.                            (href handle :controlrecord.contrlvalue) mac-setting)
  662.                      (#_SetCtlMax handle mac-max))
  663.                     (t
  664.                      (setf (href handle :controlrecord.contrlmin) mac-min
  665.                            (href handle :controlrecord.contrlmax) mac-max)
  666.                      (#_SetCtlValue handle mac-setting))))))))))
  667.  
  668.  
  669. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  670. ;;scroll-bar-length
  671. ;;
  672. ;;this is a variation of view-size
  673. ;;
  674. ;;It only used one dimension, since scroll-bars almost always have a width
  675. ;;  of 16 pixels.
  676. ;;
  677.  
  678. (defmethod scroll-bar-length ((item scroll-bar-dialog-item))
  679.   (let* ((size (view-size item))
  680.          (splitter (pane-splitter item))
  681.          (splitter-size (and splitter (view-size splitter))))
  682.     (if (eq (scroll-bar-direction item) :horizontal)
  683.       (+ (point-h size) (if splitter (point-h splitter-size) 0))
  684.       (+ (point-v size) (if splitter (point-v splitter-size) 0)))))
  685.  
  686.  
  687. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  688. ;;set-scroll-bar-length
  689. ;;
  690. ;;sets the length of the scroll-bar
  691. ;;
  692. ;;Note that because of the way this is implemented, you MUST
  693. ;;change the length of a scroll bar with a splitter with
  694. ;;set-scroll-bar-length, not by calling set-view-size directly
  695. ;;
  696.  
  697. (defun (setf scroll-bar-length) (new-length scroll-bar-dialog-item)
  698.   (set-scroll-bar-length scroll-bar-dialog-item new-length))
  699.  
  700. (defmethod set-scroll-bar-length ((item scroll-bar-dialog-item) new-length)
  701.   (let ((splitter (pane-splitter item))
  702.         (direction (scroll-bar-direction item))
  703.         (inner-length new-length))
  704.     (when splitter
  705.       (let ((size (view-size splitter)))
  706.         (decf inner-length
  707.               (min inner-length
  708.                    (if (eq direction :horizontal) (point-h size) (point-v size))))))
  709.     (set-view-size item (if (eq direction :horizontal)
  710.                           (make-point inner-length (scroll-bar-width item))
  711.                           (make-point (scroll-bar-width item) inner-length)))
  712.     (when splitter
  713.       (set-view-position item (view-position item))))
  714.   new-length)
  715.  
  716. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  717. ;;scroll-bar-width
  718. ;;
  719. ;; Sometimes you want a different width
  720. ;;
  721. (defmethod scroll-bar-width ((item scroll-bar-dialog-item))
  722.   (let ((size (view-size item)))
  723.     (if (eq (scroll-bar-direction item) :horizontal)
  724.       (point-v size)
  725.       (point-h size))))
  726.  
  727.  
  728. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  729. ;;set-scroll-bar-width
  730. ;;
  731. ;;sets the width of the scroll-bar
  732. ;;
  733. ;;Note that because of the way this is implemented, you MUST
  734. ;;change the width of a scroll bar with a splitter with
  735. ;;set-scroll-bar-width, not by calling set-view-size directly
  736. ;;
  737.  
  738. (defun (setf scroll-bar-width) (new-length scroll-bar-dialog-item)
  739.   (set-scroll-bar-width scroll-bar-dialog-item new-length))
  740.  
  741. (defmethod set-scroll-bar-width ((item scroll-bar-dialog-item) new-width)
  742.   (let ((size (view-size item)))
  743.     (set-view-size item (if (eq (scroll-bar-direction item) :horizontal)
  744.                           (make-point (point-h size) new-width)
  745.                           (make-point new-width (point-v size)))))
  746.   (let ((splitter (pane-splitter item)))
  747.     (if splitter
  748.       (let ((size (view-size splitter)))
  749.         (set-view-size splitter (if (eq (scroll-bar-direction splitter) :horizontal)
  750.                               (make-point (point-h size) new-width)
  751.                               (make-point new-width (point-v size)))))))
  752.   new-width)
  753.  
  754. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  755. ;;(setf scroll-bar-scrollee)
  756. ;;
  757. ;;Change the scrollee of a scroll-bar
  758. ;;
  759. (defun (setf scroll-bar-scrollee) (new-scrollee scroll-bar-dialog-item)
  760.   (set-scroll-bar-scrollee scroll-bar-dialog-item new-scrollee))
  761.  
  762. (defmethod set-scroll-bar-scrollee ((item scroll-bar-dialog-item) new-scrollee)
  763.   (let ((old-scrollee (scroll-bar-scrollee item)))
  764.     (when old-scrollee
  765.       (delete-view-scroll-bar old-scrollee item)))
  766.   (add-view-scroll-bar new-scrollee item)
  767.   (let ((splitter (pane-splitter item)))
  768.     (if splitter (set-scroll-bar-scrollee splitter new-scrollee)))
  769.   (setf (slot-value item 'scrollee) new-scrollee))
  770.  
  771. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  772. ;; pass set-view-container and set-view-position
  773. ;; to the pane-splitter
  774. ;;
  775. (defmethod set-view-container ((item scroll-bar-dialog-item) new-container)
  776.   (let ((splitter (pane-splitter item)))
  777.     (when splitter
  778.       (set-view-container splitter new-container))
  779.     (call-next-method)))
  780.  
  781. (defmethod set-view-position ((item scroll-bar-dialog-item) h &optional v)
  782.   (let ((pos (make-point h v))
  783.         (splitter (pane-splitter item))
  784.         (splitter-position (pane-splitter-position item)))
  785.     (setq h (point-h pos) v (point-v pos))
  786.     (when splitter
  787.       (let ((size (view-size item))
  788.             (s-size (view-size splitter)))
  789.         (if (eq (scroll-bar-direction item) :horizontal)
  790.           (if (eq splitter-position :left)
  791.             (progn (set-view-position splitter pos)
  792.                    (incf h (point-h s-size)))
  793.             (set-view-position splitter (+ h (point-h size)) v))
  794.           (if (eq splitter-position :top)
  795.             (progn (set-view-position splitter pos)
  796.                    (incf v (point-v s-size)))
  797.             (set-view-position splitter h (+ v (point-v size))))))))
  798.   (call-next-method item h v))
  799.     
  800. (defmethod corrected-view-position ((item scroll-bar-dialog-item))
  801.   (let ((splitter (pane-splitter item)))
  802.     (if (and splitter (memq (pane-splitter-position item) '(:top :left)))
  803.       (view-position splitter)
  804.       (view-position item))))
  805.  
  806. ; Change the relative position of a scroll bar's pane splitter.
  807. ;  :top <-> :bottom
  808. ; :left <-> :right
  809. (defmethod set-pane-splitter-position ((item scroll-bar-dialog-item) pos)
  810.   (let ((position (corrected-view-position item)))
  811.     (setf (slot-value item 'pane-splitter-position) pos)
  812.     (set-view-position item position))
  813.   pos)
  814.  
  815. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  816. ;;
  817. ;; set-view-size needs to invalidate the entire scroll bar
  818. ;; if it is inactive.
  819. ;;
  820. (defmethod set-view-size ((view scroll-bar-dialog-item) h &optional v)
  821.   (declare (ignore h v))
  822.   (without-interrupts
  823.    (prog1
  824.      (call-next-method)
  825.      (let ((w (view-window view)))
  826.        (when w
  827.          (unless (window-active-p w)
  828.            (multiple-value-bind (tl br) (scroll-bar-and-splitter-corners view)
  829.              (invalidate-corners 
  830.               (view-container view) (add-points tl #@(1 1)) br t))))))))
  831.  
  832. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  833. ;;
  834. ;; Methods for pane-splitter
  835. ;;
  836. (defmethod initialize-instance ((item pane-splitter) &rest initargs
  837.                                 &key (width 16) (length 5) (direction :vertical))
  838.   (declare (dynamic-extent initargs))
  839.   (let ((size (if (eq direction :vertical)
  840.                 (make-point width length)
  841.                 (make-point length width))))
  842.     (apply #'call-next-method
  843.            item
  844.            :view-size size
  845.            :direction direction
  846.            initargs)))
  847.  
  848. (defmethod view-draw-contents ((item pane-splitter))
  849.   (when (window-active-p (view-window item))
  850.     (let* ((tl (view-position item))
  851.            (br (add-points tl (view-size item))))
  852.       (rlet ((r :rect :topleft tl :botright br))
  853.         (#_FillRect r *black-pattern*)))))
  854.  
  855. (defmethod view-click-event-handler ((item pane-splitter) where)
  856.   (declare (ignore where))
  857.   (let* ((scrollee (or (scroll-bar-scrollee item) (view-window item)))
  858.          (window (view-window item))
  859.          (scroll-bar (scroll-bar item)))
  860.     (when window
  861.       (multiple-value-bind (s-tl s-br)
  862.                            (pane-splitter-corners scrollee scroll-bar)
  863.         (let* ((wait-ticks (max 1 (floor internal-time-units-per-second 30)))
  864.                (direction (scroll-bar-direction item))
  865.                (win-min -20)
  866.                (mouse-pos (view-mouse-position window))
  867.                min max min-pos max-pos drawn time pos-accessor line-direction delta pos
  868.                win-accessor win-max)
  869.           (if (eq direction :vertical)
  870.             (setq min (1+ (point-h s-tl))
  871.                   max (- (point-h s-br) 2)
  872.                   min-pos (1+ (point-v s-tl))
  873.                   max-pos (- (point-v s-br) 2)
  874.                   pos-accessor #'point-v
  875.                   win-accessor #'point-h
  876.                   win-max (+ 20 (point-h (view-size window)))
  877.                   line-direction :horizontal)
  878.             (setq min (1+ (point-v s-tl))
  879.                   max (- (point-v s-br) 2)
  880.                   min-pos (1+ (point-h s-tl))
  881.                   max-pos (- (point-h s-br) 2)
  882.                   pos-accessor #'point-h
  883.                   win-accessor #'point-v
  884.                   win-max (point-v (view-size window))
  885.                   line-direction :vertical))
  886.           ; Compute the initial position for the outline.
  887.           ; All this rigamarole is to convert from the window's coordinate system
  888.           ; to the scrollee's and back again.
  889.           (setq pos
  890.                 (let ((pos (pane-splitter-outline-position 
  891.                             scrollee scroll-bar
  892.                             (convert-coordinates mouse-pos window scrollee))))
  893.                   (funcall pos-accessor
  894.                            (convert-coordinates
  895.                             (if (eq direction :vertical)
  896.                               (make-point 0 pos)
  897.                               (make-point pos 0))
  898.                             scrollee
  899.                             window)))
  900.                 delta (- pos (funcall pos-accessor mouse-pos)))
  901.           ; Now loop until mouse up.
  902.           (flet ((draw-line (pos)
  903.                     (draw-pane-splitter-outline
  904.                      scrollee scroll-bar pos min max line-direction)
  905.                     (setq drawn (not drawn)
  906.                           time (get-internal-run-time))))
  907.             (declare (dynamic-extent #'draw-line))
  908.             (with-focused-view window
  909.               (with-pen-saved
  910.                 (#_PenPat *gray-pattern*)
  911.                 (#_PenMode (position :patxor *pen-modes*))
  912.                 (draw-line pos)
  913.                 (unwind-protect
  914.                   (loop
  915.                     (unless (mouse-down-p) (return))
  916.                     (let* ((new-mouse (view-mouse-position window))
  917.                            (new-pos (+ delta (funcall pos-accessor new-mouse)))
  918.                            (in-window (<= win-min
  919.                                           (funcall win-accessor new-mouse)
  920.                                           win-max)))
  921.                       (unless (or (eql mouse-pos new-mouse)
  922.                                   (<= (get-internal-run-time) (+ time wait-ticks)))
  923.                         (when (and drawn (or (not (eql new-pos pos)) (not in-window)))
  924.                           (draw-line pos))
  925.                         (setq pos new-pos mouse-pos new-mouse)
  926.                         (when (and (not drawn) (<= min-pos pos max-pos) in-window)
  927.                           (draw-line pos)))))
  928.                   (when drawn 
  929.                     (draw-line pos)
  930.                     (setq drawn t))))))
  931.           ; Convert back to scrollee's coordinate system
  932.           (setq pos (funcall pos-accessor (convert-coordinates 
  933.                                            (if (eq direction :horizontal)
  934.                                              (make-point pos 0)
  935.                                              (make-point 0 pos))
  936.                                            window 
  937.                                            scrollee)))
  938.           ; And call the user method to actually do something.
  939.           (split-pane scrollee scroll-bar pos direction drawn))))))
  940.  
  941. ; This controls the position of the outline when the mouse is first clicked.
  942. ; mouse-position is the position of the mouse in the coordinate system of
  943. ; the scrollee.
  944. ; The default method draws the outline right where the mouse is.
  945. (defmethod pane-splitter-outline-position (scrollee scroll-bar mouse-position)
  946.   (declare (ignore scrollee))
  947.   (if (eq (scroll-bar-direction scroll-bar) :vertical)
  948.     (point-v mouse-position)
  949.     (point-h mouse-position)))
  950.  
  951. (defmethod draw-pane-splitter-outline (scrollee scroll-bar pos min max direction)
  952.   (declare (ignore scrollee scroll-bar))
  953.   (if (eq direction :horizontal)
  954.     (progn (#_MoveTo min pos)
  955.            (#_LineTo max pos))
  956.     (progn (#_MoveTo pos min)
  957.            (#_LineTo pos max))))
  958.  
  959. ; Some users may want to specialize on this
  960. (defmethod pane-splitter-corners ((scrollee simple-view) scroll-bar)
  961.   (declare (ignore scroll-bar))
  962.   (let* ((window (view-window scrollee))
  963.          (container (view-container scrollee)))
  964.     (multiple-value-bind (tl br) (view-corners scrollee)
  965.       (when (and container (neq container window))
  966.         (setq tl (convert-coordinates tl container window)
  967.               br (convert-coordinates br container window)))
  968.       (values tl br))))
  969.  
  970. ; This is the method that all users will specialize on if they
  971. ; want a pane-splitter to do anything but draw a line.
  972. (defmethod split-pane ((scrollee simple-view) scroll-bar pos direction inside-limits)
  973.   (declare (ignore scroll-bar pos direction inside-limits)))
  974.  
  975.  
  976. (provide 'scroll-bar-dialog-items)
  977.  
  978. #|
  979. ;; a simple example.
  980. ;; Shows what the :track-thumb-p initarg does.
  981. ;; Also shows two different ways to make the scroll bar work:
  982. ;; 1) scroll bar's dialog-item-action does the work
  983. ;; 2) scrollee's scroll-bar-changed method does the work.
  984.  
  985. (defclass scroll-bar-display (static-text-dialog-item) ())
  986.  
  987. (defmethod scroll-bar-changed ((scrollee scroll-bar-display)
  988.                                scroll-bar)
  989.   (set-dialog-item-text
  990.    scrollee (format nil "~3d" (scroll-bar-setting scroll-bar)))
  991.   (view-focus-and-draw-contents scrollee))
  992.  
  993. (defun scroll-bar-example ()
  994.   (let* ((dialog (make-instance 'dialog
  995.                    :view-size #@(250 145)
  996.                    :window-title "Scroll Bar Example"))
  997.          (display (make-instance 'scroll-bar-display
  998.                     :view-position #@(25 80)
  999.                     :dialog-item-text "000"
  1000.                     :view-container dialog)))
  1001.     ; This scroll bar gets its work done via scroll-bar-changed
  1002.     ; And will update immediately when you drag its thumb.
  1003.     (make-instance 'scroll-bar-dialog-item
  1004.       :view-position #@(25 120)
  1005.       :direction :horizontal
  1006.       :length 200
  1007.       :scrollee display
  1008.       :view-container dialog
  1009.       :track-thumb-p t)
  1010.  
  1011.     ; this scroll bar does it's work itself
  1012.     ; and will respond to a thumb drag only after you're done.
  1013.     (make-instance 'static-text-dialog-item
  1014.       :view-position #@(25 10)
  1015.       :dialog-item-text "000"
  1016.       :view-nick-name 'display-text
  1017.       :view-container dialog)
  1018.     (make-instance 'scroll-bar-dialog-item
  1019.       :view-position #@(25 50)
  1020.       :direction :horizontal
  1021.       :length 200
  1022.       :view-container dialog
  1023.       :dialog-item-action
  1024.       #'(lambda (item &aux (setting (format nil "~a"
  1025.                                             (scroll-bar-setting item))))
  1026.           (set-dialog-item-text
  1027.            (find-named-sibling item 'display-text)
  1028.            setting)
  1029.           (window-update-event-handler (view-window item))))))
  1030.  
  1031. (scroll-bar-example)
  1032.  
  1033.  
  1034. |#
  1035.